home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / complex.em < prev    next >
Text File  |  1993-07-03  |  5KB  |  197 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: complex.em
  4. ;; Date: Fri Dec  4 12:22:01 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule complex
  11.   (standard0
  12.    list-fns
  13.    numbers
  14.    )
  15.   ()
  16.   
  17.  
  18.   (defclass <complex> (number)
  19.     ((real initarg real reader real-part)
  20.      (imag initarg imag reader imag-part))
  21.     )
  22.  
  23.   (defclass <gaussian> (<complex>)
  24.     ()
  25.     constructor (make-gaussian real imag))
  26.   
  27.   (defclass real-complex (<complex>)
  28.     ()
  29.     constructor (make-real-<complex> real imag))
  30.   
  31.   (defgeneric make-complex (x y)
  32.     methods ((((x <float>) (y <float>))
  33.           (make-real-complex x y))
  34.          (((x <integer>) (y <integer>))
  35.           (make-gaussian x y))
  36.          (((x <complex>) (y <complex>))
  37.           (+ x y))
  38.          (((x <number>) (y <number>))
  39.           (lift make-<complex> x y))))
  40.  
  41.   (defmethod generic-prin ((z <complex>) stream)
  42.     (format stream "#C(~a+~ai)" (real-part z) (imag-part z)))
  43.  
  44.   (defmethod generic-write ((z <complex>) stream)
  45.     (format stream "#C(~a+~ai)" (real-part z) (imag-part z)))
  46.   
  47.  
  48.   (defmethod binary+ ((z1 <complex>) (z2 <complex>))
  49.     (make-<complex> (binary+ (real-part z1) (real-part z2))
  50.           (binary+ (imag-part z1) (imag-part z2))))
  51.  
  52.   (defmethod binary- ((z1 <complex>) (z2 <complex>))
  53.     (make-<complex> (binary- (real-part z1) (real-part z2))
  54.           (binary- (imag-part z1) (imag-part z2))))
  55.  
  56.   (defmethod negate ((z1 <complex>))
  57.     (make-<complex> (negate (real-part z1))
  58.           (negate (imag-part z1))))
  59.  
  60.   (defmethod binary* ((z1 <complex>) (z2 <complex>))
  61.     (make-<complex> (binary- (binary* (real-part z1) (real-part z2))
  62.                (binary* (imag-part z1) (imag-part z2)))
  63.           (binary+ (binary* (real-part z1) (imag-part z2))
  64.                (binary* (imag-part z1) (real-part z2)))))
  65.  
  66.   (defmethod binary/ ((z1 <complex>) (z2 <complex>))
  67.     (let ((mod2 (binary+ (binary* (real-part z2) (real-part z2))
  68.              (binary* (imag-part z2) (imag-part z2)))))
  69.       (make-<complex> (binary/ (binary+ (binary* (real-part z1) (real-part z2))
  70.                       (binary* (imag-part z1) (imag-part z2)))
  71.                  mod2)
  72.             (binary/ (binary- (binary* (imag-part z1) (real-part z2))
  73.                       (binary* (real-part z1) (imag-part z2)))
  74.                  mod2))))
  75.   
  76.   (defmethod = ((z1 <complex>) (z2 <complex>))
  77.     (and (= (real-part z1) (real-part z2))
  78.      (= (imag-part z1) (imag-part z2))))
  79.  
  80.  
  81.   (defmethod quotient ((x <gaussian>) (y <gaussian>))
  82.     (binary/ x y))
  83.   
  84.   (defmethod remainder ((x <gaussian>) (y <gaussian>))
  85.     (binary- x (binary* (quotient x y) y)))
  86.  
  87.   ;; I'll leave this to someone who knows the answer....
  88.   '(defmethod binary-gcd ((x <gaussian>) (y <gaussian>))
  89.      (labels ((g-aux (a b)
  90.              (print (list a b))
  91.              (let ((r (remainder a b)))
  92.                (if (= r 0) b
  93.              (g-aux b r)))))
  94.          (g-aux x y)))
  95.            
  96.  
  97.   (defmethod lift-numbers ((x <complex>) (y <float>))
  98.     <complex>)
  99.  
  100.   (defmethod lift-numbers ((x <complex>) (y <integer>))
  101.     <complex>)
  102.  
  103.   (defmethod (converter <complex>) ((x <integer>))
  104.     (make-complex x 0))
  105.  
  106.   (defmethod (converter <complex>) ((x <float>))
  107.     (make-complex x 0))
  108.  
  109.   (defconstant i (make-complex 0 1.0))
  110.  
  111.   (defconstant I (make-complex 0 1))
  112.  
  113.   ;; end module
  114.   )
  115.  
  116. ;; Number Implementations
  117. ;; 1.
  118. (defmethod binary+ ((x number) (y number))
  119.   (let ((new-class (lift-numbers x y)))
  120.     (binary+ (convert x new-class)
  121.          (convert y new-class))))
  122.  
  123.  
  124. ;; 2.
  125. (defmethod binary+ ((x number) (y number))
  126.   (let ((new-y (coerce x y)))
  127.     (if (null new-y)
  128.     (let ((new-x (coerce y x)))
  129.       (if (null new-x)
  130.           (error "Can't do it" number-error 'error-value (cons x y))
  131.         (binary+ new-x y)))
  132.       (binary+ x new-y))))
  133.  
  134.  
  135. (defmethod coerce ((x number) (y number))
  136.   nil)
  137.  
  138.   ;; <Complex> numbers:
  139.   ;; Method 1.
  140.   ;; use lifting...
  141.  
  142.  
  143.   (defclass <complex> number
  144.     ((real initarg real accessor real-part)
  145.      (imag initarg imag accessor imag-part))
  146.     constructor (make-<complex> real imag))
  147.   
  148.  
  149.   (defconstant i (make-<complex> 0 i))
  150.  
  151.   (defmethod binary+ ((x <complex>) (y <complex>))
  152.     (make-<complex> (+ (real-part x) (real-part y))
  153.           (+ (imag-part x) (imag-part y))))
  154.  
  155.   (defmethod lift-numbers ((x <complex>) (y <integer>))
  156.     <complex>)
  157.  
  158.   (defmethod lift-numbers ((x <complex>) (y float))
  159.     <complex>)
  160.  
  161.   (defmethod lift-numbers ((y <integer>) (x <complex>))
  162.     <complex>)
  163.  
  164.   (defmethod lift-numbers ((y float) (x <complex>))
  165.     <complex>)
  166.  
  167.   (defmethod (converter <complex>) ((x float))
  168.     (make-<complex> x))
  169.  
  170.   (defmethod (converter <integer>) ((x <integer>))
  171.     (make-<complex> x))
  172.  
  173.   ;; Method 2. Coersion
  174.   ;;
  175.   
  176.   (defclass <complex> number
  177.     ((real initarg real accessor real-part)
  178.      (imag initarg imag accessor imag-part))
  179.     constructor (make-<complex> real imag))
  180.   
  181.  
  182.   (defconstant i (make-<complex> 0 i))
  183.  
  184.   (defmethod binary+ ((x <complex>) (y <complex>))
  185.     (make-<complex> (+ (real-part x) (real-part y))
  186.           (+ (imag-part x) (imag-part y))))
  187.  
  188.  
  189.   ;; Coerce forces the second arg to be of the 1st's class 
  190.   ;; or compatible.
  191.  
  192.   (defmethod coerce ((x <complex>) (y <integer>))
  193.     (make- (convert y <float>) 0))
  194.  
  195.   (defmethod coerce ((x <complex>) (y <float>))
  196.     (make-<complex> y 0))
  197.